-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Galley.API.MLS.Commit.ExternalCommit
  ( ExternalCommitAction (..),
    getExternalCommitData,
    processExternalCommit,
  )
where

import Control.Comonad
import Control.Lens (forOf_)
import Control.Monad.Codensity
import Data.Map qualified as Map
import Data.Qualified
import Data.Set qualified as Set
import Galley.API.MLS.Commit.Core
import Galley.API.MLS.IncomingMessage
import Galley.API.MLS.Proposal
import Galley.API.MLS.Removal
import Galley.API.MLS.Util
import Galley.Effects
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.Resource (Resource)
import Polysemy.State
import Wire.API.Conversation.Protocol
import Wire.API.Error
import Wire.API.Error.Galley
import Wire.API.Federation.Error
import Wire.API.MLS.CipherSuite
import Wire.API.MLS.Commit
import Wire.API.MLS.Credential
import Wire.API.MLS.LeafNode
import Wire.API.MLS.Proposal
import Wire.API.MLS.ProposalTag
import Wire.API.MLS.SubConversation
import Wire.ConversationStore
import Wire.ConversationStore.MLS.Types

data ExternalCommitAction = ExternalCommitAction
  { add :: LeafIndex,
    remove :: Maybe LeafIndex
  }

getExternalCommitData ::
  forall r.
  ( Member (Error MLSProtocolError) r,
    Member (ErrorS 'MLSStaleMessage) r,
    Member (ErrorS 'MLSUnsupportedProposal) r,
    Member (ErrorS 'MLSInvalidLeafNodeIndex) r,
    Member (ErrorS 'MLSInvalidLeafNodeSignature) r
  ) =>
  ClientIdentity ->
  Local ConvOrSubConv ->
  Epoch ->
  Commit ->
  Sem r (IndexMap, ExternalCommitAction)
getExternalCommitData senderIdentity lConvOrSub epoch commit = do
  let convOrSub = tUnqualified lConvOrSub
  activeData <-
    note (mlsProtocolError "The first commit in a group cannot be external") $
      cnvmlsActiveData convOrSub.mlsMeta
  let curEpoch = activeData.epoch
  when (epoch /= curEpoch) $ throwS @'MLSStaleMessage
  when (epoch == Epoch 0) $
    throw $
      mlsProtocolError "The first commit in a group cannot be external"
  proposals <- traverse getInlineProposal commit.proposals

  -- According to the spec, an external commit must contain:
  -- (https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol.html#section-12.2)
  --
  -- > Exactly one ExternalInit
  -- > At most one Remove proposal, with which the joiner removes an old
  -- > version of themselves.
  -- > Zero or more PreSharedKey proposals.
  -- > No other proposals.
  let counts = foldr (\x -> Map.insertWith (+) x.tag (1 :: Int)) mempty proposals

  unless (Map.lookup ExternalInitProposalTag counts == Just 1) $
    throw (mlsProtocolError "External commits must contain exactly one ExternalInit proposal")
  unless (null (Map.keys counts \\ allowedProposals)) $
    throw (mlsProtocolError "Invalid proposal type in an external commit")

  runState convOrSub.indexMap $ do
    -- process optional removal
    propAction <- applyProposals activeData.ciphersuite proposals
    removedIndex <- case cmAssocs (paRemove propAction) of
      [(cid, idx)]
        | cid /= senderIdentity ->
            throw $ mlsProtocolError "Only the self client can be removed by an external commit"
        | otherwise -> pure (Just idx)
      [] -> do
        -- no remove proposal, make sure the client is not already part of the conversation
        when (isJust (cmLookupIndex senderIdentity convOrSub.members)) $
          throw (mlsProtocolError "External commits for existing members must contain a Remove proposal")
        pure Nothing
      _ -> throw (mlsProtocolError "External commits must contain at most one Remove proposal")

    -- add sender client
    im <- get
    let (addedIndex, im') = imAddClient im senderIdentity
    put im'

    pure
      ExternalCommitAction
        { add = addedIndex,
          remove = removedIndex
        }
  where
    allowedProposals = [ExternalInitProposalTag, RemoveProposalTag, PreSharedKeyProposalTag]

    getInlineProposal :: ProposalOrRef -> Sem r Proposal
    getInlineProposal (Ref _) =
      throw (mlsProtocolError "External commits cannot reference proposals")
    getInlineProposal (Inline p) = pure p

processExternalCommit ::
  forall r.
  ( Member (Error FederationError) r,
    Member (ErrorS MLSStaleMessage) r,
    Member (ErrorS MLSIdentityMismatch) r,
    Member (ErrorS MLSSubConvClientNotInParent) r,
    Member Resource r,
    HasProposalActionEffects r,
    Member (ErrorS MLSInvalidLeafNodeSignature) r,
    Member MLSCommitLockStore r
  ) =>
  SenderIdentity ->
  Local ConvOrSubConv ->
  CipherSuiteTag ->
  Bool ->
  Epoch ->
  ExternalCommitAction ->
  Maybe UpdatePath ->
  Codensity (Sem r) ()
processExternalCommit senderIdentity lConvOrSub ciphersuite ciphersuiteUpdate epoch action mUpdatePath = do
  let convOrSub = tUnqualified lConvOrSub
      groupId = cnvmlsGroupId convOrSub.mlsMeta

  -- only members can join a subconversation
  forOf_ _SubConv convOrSub $ \(mlsConv, _) ->
    unless (isClientMember senderIdentity.client (mcMembers mlsConv)) $
      lift $
        throwS @'MLSSubConvClientNotInParent

  -- extract update path
  updatePath <-
    lift
      ( note
          (mlsProtocolError "External commits need an update path")
          mUpdatePath
      )
  lift $ checkUpdatePath lConvOrSub senderIdentity ciphersuite updatePath

  withCommitLock (fmap (.id) lConvOrSub) groupId epoch

  lift $ executeExternalCommitAction lConvOrSub senderIdentity.client action

  -- increment epoch number
  lConvOrSub' <- for lConvOrSub $ lift . incrementEpoch

  -- fetch backend remove proposals of the previous epoch
  indices0 <- lift $ getPendingBackendRemoveProposals groupId epoch

  -- skip proposals for clients already removed by the external commit
  let indices = maybe id Set.delete action.remove indices0

  -- set cipher suite
  lift $ when ciphersuiteUpdate $ case convOrSub.id of
    Conv cid -> setConversationCipherSuite cid ciphersuite
    SubConv cid sub -> setSubConversationCipherSuite cid sub ciphersuite

  -- requeue backend remove proposals for the current epoch
  createAndSendRemoveProposals
    lConvOrSub'
    (toList indices)
    (cidQualifiedUser senderIdentity.client)
    (tUnqualified lConvOrSub').members

executeExternalCommitAction ::
  forall r.
  (HasProposalActionEffects r) =>
  Local ConvOrSubConv ->
  ClientIdentity ->
  ExternalCommitAction ->
  Sem r ()
executeExternalCommitAction lconvOrSub senderIdentity action = do
  let mlsMeta = (tUnqualified lconvOrSub).mlsMeta

  -- Remove deprecated sender client from conversation state.
  for_ action.remove $ \_ ->
    removeMLSClients
      (cnvmlsGroupId mlsMeta)
      (cidQualifiedUser senderIdentity)
      (Set.singleton (ciClient senderIdentity))

  -- Add new sender client to the conversation state.
  addMLSClients
    (cnvmlsGroupId mlsMeta)
    (cidQualifiedUser senderIdentity)
    (Set.singleton (ciClient senderIdentity, action.add))
